home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / src-16f.lha / compiler / backend.lisp < prev    next >
Encoding:
Text File  |  1992-05-19  |  10.6 KB  |  310 lines
  1. ;;; -*- Package: C; Log: C.Log -*-
  2. ;;;
  3. ;;; **********************************************************************
  4. ;;; This code was written as part of the CMU Common Lisp project at
  5. ;;; Carnegie Mellon University, and has been placed in the public domain.
  6. ;;; If you want to use this code or any part of CMU Common Lisp, please contact
  7. ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
  8. ;;;
  9. (ext:file-comment
  10.   "$Header: backend.lisp,v 1.20 92/03/24 17:40:18 wlott Exp $")
  11. ;;;
  12. ;;; **********************************************************************
  13. ;;;
  14. ;;; This file isolates all the backend specific data so that we can compile
  15. ;;; and use different backends.
  16. ;;; 
  17. ;;; Written by William Lott.
  18. ;;;
  19. (in-package "C")
  20.  
  21. (export '(*backend* *target-backend* *native-backend* def-vm-support-routine
  22.       backend-name backend-version backend-fasl-file-type
  23.       backend-fasl-file-implementation backend-fasl-file-version
  24.       backend-register-save-penalty backend-byte-order
  25.       backend-any-primitive-type backend-info-environment
  26.       backend-instruction-formats backend-instruction-flavors
  27.       backend-assembler-resources backend-special-arg-types
  28.       backend-disassem-params backend-internal-errors
  29.       
  30.       ;; The various backends need to call these support routines
  31.       make-stack-pointer-tn primitive-type primitive-type-of))
  32.  
  33.  
  34. ;;;; VM support routine stuff.
  35.  
  36. (eval-when (compile eval)
  37.  
  38. (defmacro def-vm-support-routines (&rest routines)
  39.   `(progn
  40.      (eval-when (compile load eval)
  41.        (defparameter vm-support-routines ',routines))
  42.      (defstruct (vm-support-routines
  43.          (:print-function %print-vm-support-routines))
  44.        ,@(mapcar #'(lambda (routine)
  45.              `(,routine nil :type (or function null)))
  46.          routines))
  47.      ,@(mapcar
  48.     #'(lambda (name)
  49.         `(defun ,name (&rest args)
  50.            (apply (or (,(symbolicate "VM-SUPPORT-ROUTINES-" name)
  51.                (backend-support-routines *backend*))
  52.               (error "Machine specific support routine ~S ~
  53.                   undefined for ~S"
  54.                  ',name *backend*))
  55.               args)))
  56.     routines)))
  57.  
  58. ); eval-when
  59.  
  60. (def-vm-support-routines
  61.   ;; From VM.LISP
  62.   immediate-constant-sc
  63.   location-print-name
  64.   
  65.   ;; From PRIMTYPE.LISP
  66.   primitive-type-of
  67.   primitive-type
  68.   
  69.   ;; From C-CALL.LISP
  70.   make-call-out-tns
  71.   
  72.   ;; From CALL.LISP
  73.   standard-argument-location
  74.   make-return-pc-passing-location
  75.   make-old-fp-passing-location
  76.   make-old-fp-save-location
  77.   make-return-pc-save-location
  78.   make-argument-count-location
  79.   make-nfp-tn
  80.   make-stack-pointer-tn
  81.   make-number-stack-pointer-tn
  82.   make-unknown-values-locations
  83.   select-component-format
  84.   
  85.   ;; From NLX.LISP
  86.   make-nlx-sp-tn
  87.   make-dynamic-state-tns
  88.   
  89.   ;; From SUPPORT.LISP
  90.   generate-call-sequence
  91.   generate-return-sequence)
  92.  
  93. (defprinter vm-support-routines)
  94.  
  95. (defmacro def-vm-support-routine (name ll &body body)
  96.   (unless (member (intern (string name) (find-package "C"))
  97.           vm-support-routines)
  98.     (warn "Unknown VM support routine: ~A" name))
  99.   (let ((local-name (symbolicate (backend-name *target-backend*) "-" name)))
  100.     `(progn
  101.        (defun ,local-name ,ll ,@body)
  102.        (setf (,(intern (concatenate 'simple-string
  103.                     "VM-SUPPORT-ROUTINES-"
  104.                     (string name))
  105.                (find-package "C"))
  106.           (backend-support-routines *target-backend*))
  107.          #',local-name))))
  108.  
  109.  
  110.  
  111. ;;;; The backend structure.
  112.  
  113. (defstruct (backend
  114.         (:print-function %print-backend))
  115.   ;; The name of this backend.  Something like ``PMAX''
  116.   (name nil)
  117.  
  118.   ;; The version string for this backend.
  119.   ;; Something like ``DECstation 3100/Mach 0.0''
  120.   (version nil)
  121.  
  122.   ;; Information about fasl files for this backend.
  123.   (fasl-file-type nil)
  124.   (fasl-file-implementation nil)
  125.   (fasl-file-version nil)
  126.  
  127.   ;; The VM support routines.
  128.   (support-routines (make-vm-support-routines) :type vm-support-routines)
  129.  
  130.   ;; The number of references that a TN must have to offset the overhead of
  131.   ;; saving the TN across a call.
  132.   (register-save-penalty 0)
  133.  
  134.   ;; The byte order of the target machine.  Should either be :big-endian
  135.   ;; which has the MSB first (RT) or :little-endian which has the MSB last
  136.   ;; (VAX).
  137.   (byte-order nil :type (or null (member :little-endian :big-endian)))
  138.  
  139.   ;; Translates from SC numbers to SC info structures.  SC numbers are always
  140.   ;; used instead of names at run time, so changing this vector changes all the
  141.   ;; references.
  142.   (sc-numbers (make-array sc-number-limit :initial-element nil)
  143.           :type sc-vector)
  144.  
  145.   ;; A list of all the SBs defined, so that we can easily iterate over them.
  146.   (sb-list () :type list)
  147.  
  148.   ;; Translates from template names to template structures.
  149.   (template-names (make-hash-table :test #'eq) :type hash-table)
  150.  
  151.   ;; Hashtable from SC and SB names the corresponding structures.  The META
  152.   ;; versions are only used at meta-compile and load times, so the defining
  153.   ;; macros can change these at meta-compile time without breaking the
  154.   ;; compiler.
  155.   (sc-names (make-hash-table :test #'eq) :type hash-table)
  156.   (sb-names (make-hash-table :test #'eq) :type hash-table)
  157.   (meta-sc-names (make-hash-table :test #'eq) :type hash-table)
  158.   (meta-sb-names (make-hash-table :test #'eq) :type hash-table)
  159.  
  160.   ;; Like *SC-Numbers*, but is updated at meta-compile time.
  161.   (meta-sc-numbers (make-array sc-number-limit :initial-element nil)
  162.            :type sc-vector)
  163.  
  164.   ;; Translates from primitive type names to the corresponding primitive-type
  165.   ;; structure.
  166.   (primitive-type-names (make-hash-table :test #'eq) :type hash-table)
  167.  
  168.   ;; Establishes a convenient handle on primitive type unions, or whatever.
  169.   ;; These names can only be used as the :arg-types or :result-types for VOPs
  170.   ;; and can map to anything else that can be used as :arg-types or
  171.   ;; :result-types (e.g. :or, :constant).
  172.   (primitive-type-aliases (make-hash-table :test #'eq) :type hash-table)
  173.  
  174.   ;; Meta-compile time translation from names to primitive types.
  175.   (meta-primitive-type-names (make-hash-table :test #'eq) :type hash-table)
  176.  
  177.   ;; The primitive type T is somewhat magical, in that it is the only
  178.   ;; primitive type that overlaps with other primitive types.  An object
  179.   ;; of primitive-type T is in the canonical descriptor (boxed or pointer)
  180.   ;; representation.
  181.   ;;
  182.   ;; We stick the T primitive-type in a variable so that people who have to
  183.   ;; special-case it can get at it conveniently.  This is done by the machine
  184.   ;; specific VM definition, since the DEF-PRIMITIVE-TYPE for T must specify
  185.   ;; the SCs that boxed objects can be allocated in.
  186.   (any-primitive-type nil :type (or null primitive-type))
  187.  
  188.   ;; Hashtable translating from VOP names to the corresponding VOP-Parse
  189.   ;; structures.  This information is only used at meta-compile time.
  190.   (parsed-vops (make-hash-table :test #'eq) :type hash-table)
  191.  
  192.   ;; The backend specific aspects of the info environment.
  193.   (info-environment nil :type list)
  194.  
  195.   ;; Support for the assembler.
  196.   (instruction-formats (make-hash-table :test #'eq) :type hash-table)
  197.   (instruction-flavors (make-hash-table :test #'equal) :type hash-table)
  198.   (special-arg-types (make-hash-table :test #'eq) :type hash-table)
  199.   (assembler-resources nil :type list)
  200.  
  201.   ;; The backend specific features list, if any.  During a compilation,
  202.   ;; *features* is bound to *features* - misfeatures + features.
  203.   (%features nil :type list)
  204.   (misfeatures nil :type list)
  205.  
  206.   ;; Disassembler information.
  207.   (disassem-params nil :type t)
  208.  
  209.   ;; Mappings between CTYPE structures and the corresponding predicate.
  210.   ;; The type->predicate mapping hash is an alist because there is no
  211.   ;; such thing as a type= hash table.
  212.   (predicate-types (make-hash-table :test #'eq) :type hash-table)
  213.   (type-predicates nil :type list)
  214.  
  215.   ;; Vector of the internal errors defined for this backend, or NIL if
  216.   ;; they haven't been installed yet.
  217.   (internal-errors nil :type (or simple-vector null)))
  218.  
  219.  
  220. (defprinter backend
  221.   name)
  222.  
  223.  
  224. (defvar *native-backend* (make-backend)
  225.   "The backend for the machine we are running on. Do not change this.")
  226. (defvar *target-backend* *native-backend*
  227.   "The backend we are attempting to compile.")
  228. (defvar *backend* *native-backend*
  229.   "The backend we are using to compile with.")
  230.  
  231.  
  232.  
  233. ;;;; Other utility functions for fiddling with the backend.
  234.  
  235. (export '(backend-features target-featurep backend-featurep native-featurep))
  236.  
  237. (defun backend-features (backend)
  238.   "Compute the *FEATURES* list to use with BACKEND."
  239.   (union (backend-%features backend)
  240.      (set-difference *features*
  241.              (backend-misfeatures backend))))
  242.  
  243. (defun target-featurep (feature)
  244.   "Same as EXT:FEATUREP, except use the features found in *TARGET-BACKEND*."
  245.   (let ((*features* (backend-features *target-backend*)))
  246.     (featurep feature)))
  247.  
  248. (defun backend-featurep (feature)
  249.   "Same as EXT:FEATUREP, except use the features found in *BACKEND*."
  250.   (let ((*features* (backend-features *backend*)))
  251.     (featurep feature)))
  252.  
  253. (defun native-featurep (feature)
  254.   "Same as EXT:FEATUREP, except use the features found in *NATIVE-BACKEND*."
  255.   (let ((*features* (backend-features *native-backend*)))
  256.     (featurep feature)))
  257.  
  258.  
  259. ;;; NEW-BACKEND
  260. ;;;
  261. ;;; Utility for creating a new backend structure for use with cross
  262. ;;; compilers.
  263. ;;;
  264. (defun new-backend (name features misfeatures)
  265.   ;; If VM names a different package, rename that package so that VM doesn't
  266.   ;; name it.  
  267.   (let ((pkg (find-package "VM")))
  268.     (when pkg
  269.       (let ((pkg-name (package-name pkg)))
  270.     (unless (string= pkg-name name)
  271.       (rename-package pkg pkg-name
  272.               (remove "VM" (package-nicknames pkg)
  273.                   :test #'string=))
  274.       (unuse-package pkg "C")))))
  275.   ;; Make sure VM names our package, creating it if necessary.
  276.   (let* ((pkg (or (find-package name)
  277.           (make-package name :nicknames '("VM"))))
  278.      (nicknames (package-nicknames pkg)))
  279.     (unless (member "VM" nicknames :test #'string=)
  280.       (rename-package pkg name (cons "VM" nicknames)))
  281.     ;; And make sure we are using the necessary packages.
  282.     (use-package "C" pkg)
  283.     (use-package "ASSEM" pkg)
  284.     (use-package "EXT" pkg)
  285.     (use-package "KERNEL" pkg)
  286.     (use-package "SYSTEM" pkg)
  287.     (use-package "ALIEN" pkg)
  288.     (use-package "C-CALL" pkg))
  289.   ;; Make sure the native info env list is stored in *native-backend*
  290.   (unless (backend-info-environment *native-backend*)
  291.     (setf (backend-info-environment *native-backend*) *info-environment*))
  292.   ;; Cons up a backend structure, filling in the info-env and features slots.
  293.   (let ((backend (make-backend
  294.           :name name
  295.           :info-environment
  296.           (cons (make-info-environment
  297.              :name
  298.              (concatenate 'string name " backend"))
  299.             (remove-if #'(lambda (name)
  300.                        (let ((len (length name)))
  301.                      (and (> len 8)
  302.                           (string= name " backend"
  303.                                :start1 (- len 8)))))
  304.                    *info-environment*
  305.                    :key #'info-env-name))
  306.           :%features features
  307.           :misfeatures misfeatures)))
  308.     (setf *target-backend* backend)))
  309.  
  310.